#!/usr/bin/perl -w
#
# run `perldoc apot.pl` or `perl apot.pl --man` for help.
#
#
# ChangeLog:
#
# 2007/06/22    0.1
#   support TP web site
# 2007/06/23    0.2
#   support Debian l10n web site
# 2007/06/24    0.3
#   support APT like sub commands
# 2007/06/25    0.3.1
#   support new TP web site
#
use strict;
use warnings;
use Data::Dumper;          # for debug
use Getopt::Long;
use HTML::TreeBuilder;
use LWP::Simple;
use Pod::Usage;

my $APOT_VERSION    = "0.3.1";

my $g_dir           = 'cache';
my $g_output_file   = 'index';
my $g_input_file    = 'index';
my $g_language      = $ENV{LANG} || 'zh_CN';
my %g_patterns      = ();
my $g_format;
my $g_force         = 0;
my $g_man           = 0;
my $g_help          = 0;

GetOptions('dir|d=s'    => \$g_dir,
           'output|o=s' => \$g_output_file,
           'input|i=s'  => \$g_input_file,
           'lang|l=s'   => \$g_language,
           'pattern|p=s'=> \%g_patterns,
           'force!'     => \$g_force,
           'format|f=s' => \$g_format,
           'help|h'     => \$g_help,
           'man'        => \$g_man,
           'version|V'  => \&show_version) ||
               die "See help with --help option.\n";
pod2usage(1) if $g_help;
pod2usage(-exitstatus => 0, -verbose => 2) if $g_man;

my $cmd = shift;
my %commands = (
    'download'  => \&cmd_wrapper,
    'search'    => \&cmd_wrapper,
    'update'    => \&cmd_update
);

my %wrapper_commands = (
    'download'  => \&cmd_download,
    'search'    => \&cmd_search
);

$Data::Dumper::Maxdepth = 3;        # for debug

if (!defined $cmd || !exists $commands{$cmd}) {
    print STDERR "apot: missing or unkown sub command.\n\n";
    pod2usage(1);
} else {
    if ($commands{$cmd} eq \&cmd_wrapper) {
        cmd_wrapper($cmd, @ARGV);
    } else {
        $commands{$cmd}->(@ARGV);
    }
}


#################   SUBROUTINES   ##################################################

sub cmd_wrapper {
    my $fh = \*STDIN;
    my $cmd = shift;

    if ('-' ne $g_input_file) {
        open $fh, "<:utf8", $g_input_file || die "Can't open $g_input_file:$!\n";
    }
    binmode $fh, ":utf8";

    my $pkgs = load_po_infos($fh);

    my @keys = keys %g_patterns;
    my $po_infos;

    if (@keys == 0) {
        if (@_ == 0) {
            print STDERR "apot: missing patterns, use `apot --help' to get help.\n";
            goto label_cleanup;
        }
        $po_infos = search_po_infos($pkgs, 'name', shift);
    } else {
        my %patterns2 = ();
        map {
            $patterns2{$_} = $g_patterns{$_} if exists $g_patterns{$_};
        } qw(name language version maintainer url status);

        my @keys2 = keys %patterns2;
        if (@keys != @keys2) {
            print STDERR "apot: wrong patterns, use `apot --help' to get help.\n";
            goto label_cleanup;
        }

        $po_infos = search_po_infos($pkgs, %g_patterns);
    }

    $wrapper_commands{$cmd}->($po_infos, @_);

label_cleanup:
    if ('-' ne $g_input_file) {
        close $fh;
    }
}


sub cmd_download {
    my $po_infos = shift;
    my $local_file;

    foreach my $p (@$po_infos) {
        $local_file = $p->{url};
        $local_file = substr $local_file, rindex($local_file, '/') + 1;
        my $status  = $p->{status};
        $status     =~ s/;/_/g;
        $local_file = $status . '-' . $local_file;
        $local_file = File::Spec->catfile($g_dir, $local_file);

        fetch_webpage($p->{url}, $local_file);
    }
}


sub cmd_search {
    my $po_infos = shift;
    binmode STDOUT, ":utf8";
    dump_po_infos($po_infos, \*STDOUT);
}


sub cmd_update {
    my @websites = map(lc, @_);
    my $fh = \*STDOUT;
    my ($do_tp, $do_debian);

    if (@websites == 0) {
        ($do_tp, $do_debian) = (1, 1);
    } else {
        ($do_tp, $do_debian) = (0, 0);
        foreach my $site (@websites) {
            if ($site eq 'tp') {
                $do_tp = 1;
            } elsif ($site eq 'debian') {
                $do_debian = 1;
            } else {
                print STDERR "apot: Unsupport web site '$site'.\n\n";
                pod2usage(1);
            }
        }
    }

    if ('-' ne $g_output_file) {
        die "Can't overwrite $g_output_file, need '--force' option.\n"
            if -f $g_output_file && ! $g_force;
        open $fh, ">:utf8", $g_output_file || die "Can't open $g_output_file:$!\n";
    }
    binmode $fh, ":utf8";

    if (! -e $g_dir) {
        mkdir $g_dir || die "Can't mkdir $g_dir:$!\n";
    }

    undef $g_format;        # `update' command uses standard format
    ####################################
    # process web pages
    my @po_infos;

    if ($do_tp) {
        @po_infos = process_TP_web_pages($g_dir, $g_language);
        dump_po_infos(\@po_infos, $fh);
    }

    if ($do_debian) {
        @po_infos = process_Debian_l10n_page($g_dir, $g_language);
        dump_po_infos(\@po_infos, $fh);
    }

    ####################################
    # cleanup
    if ('-' ne $g_output_file) {
        close $fh;
    }
}


sub process_TP_web_pages {
    my ($local_dir, $language) = @_;
    my $team_page_url = "http://www.translationproject.org/team/";
    #my $team_page_url = "http://www.iro.umontreal.ca/translation/registry.cgi?team=";
    my $domain_page_url = "http://www.translationproject.org/domain/";
    my ($ret, $local_file);

    $language   ||= "zh_CN";
    $local_file = File::Spec->catfile($local_dir, "tp_team_" . $language . ".html");

    $ret = fetch_webpage($team_page_url . $language . ".html", $local_file);
    if (-1 == $ret) {
        return ();
    }

    my @pkgs = parse_TP_team_page($local_file);
    my @po_infos = ();
    foreach (@pkgs) {
        $local_file = File::Spec->catfile($local_dir, "tp_" . $_ .  ".html");
        $ret = fetch_webpage($domain_page_url . $_ . ".html", $local_file);
        if (-1 == $ret) {
            next;
        }
        push @po_infos, parse_TP_domain_page($_, $local_file, $language);
    }

    # adjust relative url
    foreach my $po_info (@po_infos) {
        if (index($po_info->{url}, '://') < 0) {
            $po_info->{url} = $domain_page_url . $po_info->{url};
            $po_info->{url} =~ s/\/[^\/]+\/+\.\.//g;
        }
    }

    return @po_infos;
}


#
# download a web page from remote server.
#
# fetch_webpage($url, $local_file)
#
# returns:
#   1       new
#   0       not modifed
#   -1      error
#
sub fetch_webpage {
    my ($url, $local_file) = @_;
    my $ret;
    
    if (!$g_force && -e $local_file) {
        print STDERR "cached $url in $local_file.\n";
        $ret = RC_OK;
    } else {
        print STDERR "fetching $url to $local_file ...\n";
        $ret = mirror($url, $local_file);
    }

    if ($ret == RC_NOT_MODIFIED) {
        print STDERR "Got it(not modified)!\n";
        return 0;
    } elsif ($ret == RC_OK) {
        print STDERR "Got it!\n";
        return 1;
    }

    print STDERR "Failed!\n";
    return -1;
}


sub parse_TP_team_page {
    my $local_file = shift;

    my $domain_page_url = "../domain/";
    my $tree = new HTML::TreeBuilder();
    $tree->parse_file($local_file);
    my $domain_th = $tree->look_down('_tag', 'th',
                                     sub {
                                         'Domain' eq $_[0]->as_trimmed_text();
                                     });
    # <table> <tr> <th>Domain</th>...</tr>...</table>
    my $links = $domain_th->parent()->parent()->extract_links('a');

    my $len = length $domain_page_url;

    my ($link, $element, $pkg);
    my @pkgs = ();
    foreach (@$links) {
        ($link, $element) = @$_;
        if (0 == index($link, $domain_page_url)) {
            # $link: ../domain/binutils.html
            $pkg = substr($link, $len, -5);

            #
            #          ___ $element
            # <tr>    /
            #   <td><a href=pkg>...</a></td>
            #   <td><a href=mail>...</a></td>
            #   <td>Version</td>
            #   <td>Translated</td>
            #   <td>current version</td>
            #   <td>translated</td>
            # </tr>

            # has translator for this language?
            if (defined $element->parent()->right()->find_by_tag_name('a')) {
                push @pkgs, $pkg;
            }
        }
    }

    $tree->delete;
    return @pkgs;
}


sub parse_TP_domain_page {
    my ($pkgname, $local_file, $language) = @_;
    my @pkgs = ();
    my $pkg = {};   # {name         => 'binutils',
                    #  language     => 'zh_CN',
                    #  version      => '2.16.93',
                    #  maintainer   => 'Wang Li<charles@linux.net.cn>',
                    #  url          => 'http://.../zh_CN/binutils-2.16.93.zh_CN.po',
                    #  status       => '995/626/0'}

    my $tree = new HTML::TreeBuilder();
    $tree->parse_file($local_file);

    # <td ...>zh_CN</td>
    my $td = $tree->look_down('_tag', 'td',
                              sub {
                                  $language eq $_[0]->as_trimmed_text();
                              });
    return () if !defined $td;
    my $count = $td->attr('rowspan');
    $count ||= 1;
    my $tr = $td->parent;

    my (@children, $status, $mail, $url, $ver, $h, @t);
    do {
        @children = $tr->content_list();

        $status = $children[$#children]->as_trimmed_text();
        @t = split / \/ /, $status;
        # translated/untranslated/fuzzy
        $status = "$t[0]t;" . "0f;" . ($t[1] - $t[0]) . "u";

        $h = $children[$#children - 1]->find_by_tag_name('a');
        $mail = $h->as_trimmed_text() . "<" .  $h->attr('href') . ">";
        $mail =~ s/mailto://;
        $mail =~ s/ \(at\) /\@/;
        $mail =~ s/ \(dot\) /\./g;


        $h = $children[$#children - 2]->find_by_tag_name('a');
        $ver = $h->as_trimmed_text();
        $url = $h->attr('href');

        $pkg->{name}        = $pkgname;
        $pkg->{language}    = $language;
        $pkg->{version}     = $ver;
        $pkg->{maintainer}  = $mail;
        $pkg->{url}         = $url;
        $pkg->{status}      = $status;

        push @pkgs, $pkg;

        $pkg = {};
        $tr = $tr->right;
    } while (--$count > 0);

    $tree->delete;
    return @pkgs;
}


sub process_Debian_l10n_page {
    my ($local_dir, $language) = @_;
    my $debian_l10n_url = "http://www.debian.org/intl/l10n/po/";
    my ($ret, $local_file);

    $language   ||= "zh_CN";
    $local_file = File::Spec->catfile($local_dir, "debian_" . $language .  ".html");

    $ret = fetch_webpage($debian_l10n_url . $language, $local_file);
    if (-1 == $ret) {
        return ();
    }

    my @po_infos = parse_Debian_l10n_page($local_file, $language);
    return @po_infos;
}


sub parse_Debian_l10n_page {
    my ($local_file, $language) = @_;
    my @pkgs = ();
    my $pkg = {};
    
    my $tree = new HTML::TreeBuilder();
    $tree->parse_file($local_file);

    my @sections = $tree->look_down('_tag', 'h3',
                                    sub {
                                        0 == index($_[0]->as_trimmed_text(),
                                                   'Section');
                                    });

    my ($section, $table, @rows, @cols, $tr);
    my ($name, $status, $url, $mail, $version);
    foreach $section (@sections) {
        $table = $section->right;
        next if !defined $table;

        @rows = $table->content_list();
        next if @rows < 2;
        shift @rows;    # remove the table header

        foreach $tr (@rows) {
            @cols    = $tr->content_list();
            
            $name      = $cols[0]->as_trimmed_text();
            $status    = $cols[1]->as_trimmed_text();
            ($status)  = $status =~ /\((.*)\)/;
            $url       = $cols[2]->find_by_tag_name('a')->attr('href');
            $mail      = $cols[3]->as_trimmed_text() .  "<" .
                         $cols[4]->as_trimmed_text() .  ">";
            $mail      =~ s/ at /\@/;
            $mail      =~ s/ dot /\./g;
            ($version) = $url =~ /[_\-](\d+[^\/]*?)_(:?$language)?[^\/]*po[^\/]*$/go;
            $version   =~ s/%3a/:/g;
            

            $pkg->{name}        = $name;
            $pkg->{language}    = $language;
            $pkg->{version}     = $version;
            $pkg->{maintainer}  = $mail;
            $pkg->{url}         = $url;
            $pkg->{status}      = $status;

            push @pkgs, $pkg;
            $pkg = {};
        }
    }

    return @pkgs;
}


# $po_infos = ({name => '...', language => '...', ...},
#              {name => '...', language => '...', ...},
#              ...);
sub dump_po_infos {
    my ($po_infos, $fh) = @_;

    if (defined $g_format) {
        # %N or %n: name
        # %L or %l: language
        # %V or %v: version
        # %m      : maintainer's name
        # %M      : maintainer's email
        # %U or %u: url
        # %S or %s: status
        my @a = $g_format =~ /%.*?([NnLlVvmMUuSs])/g;
        my $args = '';
        foreach (@a) {
            if ($_ eq 'N' || $_ eq 'n') {
                $args .= q/, $p->{name}/;
            } elsif ($_ eq 'L' || $_ eq 'l') {
                $args .= q/, $p->{language}/;
            } elsif ($_ eq 'V' || $_ eq 'v') {
                $args .= q/, $p->{version}/;
            } elsif ($_ eq 'm') {
                $args .= q/, substr($p->{maintainer}, 0, index($p->{maintainer}, '<'))/;
            } elsif ($_ eq 'M') {
                $args .= q/, substr($p->{maintainer}, index($p->{maintainer}, '<') + 1, -1)/;
            } elsif ($_ eq 'U' || $_ eq 'u') {
                $args .= q/, $p->{url}/;
            } elsif ($_ eq 'S' || $_ eq 's') {
                $args .= q/, $p->{status}/;
            } else {
                print STDERR "apot: unkown format\n";
                return;
            }
        }
        return if ('' eq $args);

        $args .= ';';
        my $format = $g_format;
        $format =~ s/(%.*?)([NnLlVvmMUuSs])/$1s/g;
        my $print_clause = 'printf $fh "' . $format . '"'. $args;
        
        foreach my $p (@$po_infos) {
            eval $print_clause;
        }
    } else {
        foreach my $p (@$po_infos) {
            map {print $fh "$_: ", defined($p->{$_}) ? $p->{$_} : "", "\n";}
                    qw(name language version maintainer url status);
            print "\n";
        }
    }
}


sub load_po_infos {
    my $fh   = shift;
    my @po_infos = ();
    my $pkg  = {};

    my ($key, $value, $i);
    while (<$fh>) {
        chomp;
        $i = index $_, ':';
        if ($i >= 0) {
            $key    = substr $_, 0, $i;
            $value  = substr $_, $i + 2;
            $pkg->{$key} = $value;
        } else {
            next if ! exists $pkg->{'name'};
            push @po_infos, $pkg;
            $pkg = {};
        }
    }

    return \@po_infos;
}


sub search_po_infos {
    my ($po_infos, %patterns) = @_;
    my @result = ();

    my ($ok, $key);
    my @keys = keys %patterns;
    foreach my $po (@$po_infos) {
        $ok = 1;
        foreach $key (@keys) {
            if ($po->{$key} !~ /$patterns{$key}/i) {
                $ok = 0;
                last;
            }
        }
        push @result, $po if $ok;
    }

    return \@result;
}


sub show_version {
    print STDERR <<"EOF";
apot $APOT_VERSION

Copyright 2007 Liu Yubao. 
This is free software.  You may redistribute copies of it under the terms
of the GNU  General  Public License <http://www.gnu.org/licenses/gpl.html>.
There  is  NO WARRANTY, to the extent permitted by law.

Supported web sites:
* tp
    http://www.translationproject.org/
* debian
    http://www.debian.org/intl/l10n

EOF
    exit(0);
}

__END__

=head1 NAME

apot - get translation status of PO files from many web sites

=head1 SYNOPSIS

 apot --help|-h|--man|--version|-V
 apot update [-d <cache>] [-o <index>] [-l <lang>] [--force] [tp] [debian]
 apot search [-i <index>] [-l <lang>] [<pattern> | -p <k>=<v>] [-f <format>]
 apot download [-d <cache>] [-i <index>] [-l <lang>] [<pattern> | -p <k>=<v>]

 Options:
   -d, --dir=<cache>       cache web pages or po files in this directory.
   -o, --output=<index>    output information about PO files to this file.
   -i, --input=<index>     read information about PO files from this file.
   -l, --lang=<lang>       fetch information about this language.
   -p, --pattern key=value specify search patterns.
   --force                 force to overwrite existent file.
   -f, --format            specify output format.
   -h, --help              brief help message.
   --man                   full documentation.
   -V, --version           version information.

=head1 OPTIONS

=over 8

=item B<--dir>

The directory in which web pages and po files are cached, I<'cache'> by
default. If you want to download the latest file you should provide a
new directory or delete files in this directory or provide I<--force>
option.

=item B<--force>

Force to overwrite existent file.

=item B<--output>

Output information about PO files to this file, I<'index'> by default.
'-' means stdout.

=item B<--input>

Read information about PO files from this file, I<'index'> by default.
'-' means stdin.

=item B<--lang>

Check information only for this language, set to environment variable
LANG if omitted, or to 'zh_CN' if LANG is not set.

=item B<--pattern>

Specify search patterns. Patterns can be used to match I<name>, I<language>,
I<version>, I<maintainer>, I<url> and I<status> of a PO file. This option
can occur many times. For example,

    apot search -p name=cjk -p maintainer="^Carlos"

If omit this option, the argument following I<'search'> or I<'download'>
sub command is taken as a pattern to match name of PO information, for
example:

    apot search cjk

=item B<--format>

Specify format for output of search sub commands, each property of a PO
file has corresponding format keyword:

    %N or %n: name
    %L or %l: language
    %V or %v: version
    %m      : maintainer's name
    %M      : maintainer's email
    %U or %u: url
    %S or %s: status

For example:

    apot search gnome --format "%-25N%-15V%-15S%15m  %M\n"

=item B<--help>

Print a brief help message and exits.

=item B<--man>

Print the manual page and exits.

=item B<--version>

Print version information and exit.

=back

=head1 DESCRIPTION

There are many web sites managing translated PO files, for examples:

=over 8

=item L<http://www.translationproject.org>

Translation project for some GNU softwares.

=item L<http://www.debian.org/intl/l10n>

Translations for Debian GNU/Linux distribution.

=item L<https://translations.launchpad.net>

Translations for Ubuntu Linux distribution.

=item L<http://l10n.gnome.org>

Translations for GNOME desktop environment.

=item L<http://l10n.kde.org>

Translations for KDE desktop environment.

=item L<http://code.google.com/p/i18n-zh/>

Chinese translations for some open source softwares.

=back

It's convenient to gather information about PO files from these
web sites automatically, so I don't have to click many many links
to find what I need.

Further more, B<apot> imitates the user interface of Debian APT
to provide some commands like `update', `download', `search' etc, 
then one can fetch latest PO files easily.

=head1 TODO

Support more translation projects.

=head1 AUTHOR

Written by Liu Yubao 2007/06/22.

=head1 BUGS

Test me, report bugs to <yubao.liu aT gmail d0T com>.

=head1 COPYRIGHT

Copyright (C) 2007 Liu Yubao, licensed under the GPL version 2.

=cut

